home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / filetool.cls < prev    next >
Text File  |  1997-06-14  |  16KB  |  427 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GFileTool"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EErrorFileTool
  13.     eeBaseFileTool = 13480      ' FileTool
  14. End Enum
  15.  
  16. Public Enum EWalkModeFile
  17.     ewmfDirs = &H20
  18.     ewmfFiles = &H40
  19.     ewmfBoth = &H20 Or &H40
  20. End Enum
  21.  
  22. Private Declare Function SHFileOperation Lib "shell32.dll" _
  23.     Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
  24.  
  25. Private Type SHFILEOPSTRUCT
  26.     hWnd As Long                ' Window owner of any dialogs
  27.     wFunc As Long               ' Copy, move, rename, or delete code
  28.     pFrom As String             ' Source file
  29.     pTo As String               ' Destination file or directory
  30.     fFlags As Integer           ' Options to control the operations
  31.     fAnyOperationsAbortedLo As Integer ' Indicates partial failure
  32.     fAnyOperationsAbortedHi As Integer
  33.     hNameMappingsLo As Long     ' Array indicating each success
  34.     hNameMappingsHi As Long
  35.     lpszProgressTitleLo As Long ' Title for progress dialog
  36.     lpszProgressTitleHi As Long
  37. End Type
  38.  
  39. Const datMin As Date = #1/1/100#
  40. Const datMax  As Date = #12/31/9999 11:59:59 PM#
  41.  
  42. ' Difference between day zero for VB dates and Win32 dates
  43. ' (or #12-30-1899# - #01-01-1601#)
  44. Const rDayZeroBias As Double = 109205#   ' Abs(CDbl(#01-01-1601#))
  45.  
  46. ' 10000000 nanoseconds * 60 seconds * 60 minutes * 24 hours / 10000
  47. ' comes to 86400000 (the 10000 adjusts for fixed point in Currency)
  48. Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#
  49.  
  50. Function Win32ToVbTime(ft As Currency) As Date
  51.     Dim ftl As Currency
  52.     ' Call API to convert from UTC time to local time
  53.     If FileTimeToLocalFileTime(ft, ftl) Then
  54.         ' Local time is nanoseconds since 01-01-1601
  55.         ' In Currency that comes out as milliseconds
  56.         ' Divide by milliseconds per day to get days since 1601
  57.         ' Subtract days from 1601 to 1899 to get VB Date equivalent
  58.         Win32ToVbTime = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)
  59.     Else
  60.         ApiRaise Err.LastDllError
  61.     End If
  62. End Function
  63.  
  64. Function VbToWin32Time(dat As Date) As Currency
  65.     Dim ftl As Currency
  66.     ' Date is days since 1899
  67.     ' Add days from 1601 to 1899 to get Win32 days
  68.     ' Multiply by milliseconds per day to get milliseconds since 1601
  69.     ' That would be nanoseconds if it weren't in Currency
  70.     ftl = CCur((CDbl(dat) + rDayZeroBias) * rMillisecondPerDay)
  71.     ' Call API to convert from local time to UTC time
  72.     If LocalFileTimeToFileTime(ftl, VbToWin32Time) = 0 Then
  73.         ApiRaise Err.LastDllError
  74.     End If
  75. End Function
  76.  
  77. Function FileAnyDateTime(sPath As String, _
  78.                          Optional datCreation As Date = datMin, _
  79.                          Optional datAccess As Date = datMin) As Date
  80.     ' Take the easy way if no optional arguments
  81.     If datCreation = datMin And datAccess = datMin Then
  82.         FileAnyDateTime = VBA.FileDateTime(sPath)
  83.         Exit Function
  84.     End If
  85.             
  86.     Dim fnd As WIN32_FIND_DATA
  87.     Dim ftCreate As FILETIME, ftAccess As FILETIME, ftModify As FILETIME
  88.     Dim hFind As Long, f As Boolean, stime As SYSTEMTIME
  89.     ' Get all three times in UDT
  90.     hFind = FindFirstFile(sPath, fnd)
  91.     If hFind = hInvalid Then ApiRaise Err.LastDllError
  92.     FindClose hFind
  93.     ' Convert them to Visual Basic format
  94.     datCreation = Win32ToVbTime(fnd.ftCreationTime)
  95.     datAccess = Win32ToVbTime(fnd.ftLastAccessTime)
  96.     FileAnyDateTime = Win32ToVbTime(fnd.ftLastWriteTime)
  97. End Function
  98.  
  99. Sub ReplaceFile(sOld As String, sTmp As String)
  100.     Dim fnd As WIN32_FIND_DATA, hFind As Long, hOld As Long, f As Boolean
  101.     ' Get file time and attributes of old file
  102.     hFind = FindFirstFile(sOld, fnd)
  103.     If hFind = hInvalid Then ApiRaise Err.LastDllError
  104.     ' Replace by deleting old and renaming new to old
  105.     Kill sOld
  106.     Name sTmp As sOld
  107.     ' Assign old attributes and time to new file
  108.     hOld = lopen(sOld, OF_WRITE Or OF_SHARE_DENY_WRITE)
  109.     If hOld = hInvalid Then ApiRaise Err.LastDllError
  110.     f = SetFileTime(hOld, fnd.ftCreationTime, _
  111.                     fnd.ftLastAccessTime, fnd.ftLastWriteTime)
  112.     If f Then ApiRaise Err.LastDllError
  113.     lclose hOld
  114.     f = SetFileAttributes(sOld, fnd.dwFileAttributes)
  115.     If f Then ApiRaise Err.LastDllError
  116. End Sub
  117.  
  118. ' Better version of FileCopy (CopyAnyFile) and matching MoveAnyFile,
  119. ' DeleteAnyFile, and RenameAnyFile
  120.  
  121. Function CopyAnyFile(sSrc As String, sDst As String, _
  122.                      Optional Options As Long = 0, _
  123.                      Optional Owner As Long = hNull) As Boolean
  124.     If MUtility.HasShell Then
  125.         Dim fo As SHFILEOPSTRUCT, f As Long
  126.         fo.wFunc = FO_COPY
  127.         Debug.Print TypeName(fo.wFunc)
  128.         fo.pFrom = sSrc
  129.         fo.pTo = sDst
  130.         fo.fFlags = Options
  131.         fo.hWnd = Owner
  132.         ' Mask out invalid flags
  133.         fo.fFlags = fo.fFlags And FOF_COPYFLAGS
  134.         f = SHFileOperation(fo)
  135.         CopyAnyFile = (f = 0)
  136.     Else
  137.         ' For Windows NT 3.51
  138.         On Error Resume Next
  139.         ' FileCopy expects full name of destination file
  140.         FileCopy sSrc, sDst
  141.         If Err Then
  142.             Err = 0
  143.             ' CopyAnyFile can handle destination directory
  144.             sDst = MUtility.NormalizePath(sDst) & _
  145.                    MUtility.GetFileBaseExt(sSrc)
  146.             FileCopy sSrc, sDst
  147.         End If
  148.         ' Enhance further to emulate SHFileOperation options
  149.         ' such as validation and wild cards
  150.         CopyAnyFile = (Err = 0)
  151.     End If
  152. End Function
  153.  
  154. Function MoveAnyFile(sSrc As String, sDst As String, _
  155.                   Optional afOptions As Long = 0, _
  156.                   Optional Owner As Long = hNull) As Boolean
  157.     If MUtility.HasShell Then
  158.         Dim fo As SHFILEOPSTRUCT, f As Long
  159.         fo.wFunc = FO_MOVE
  160.         fo.pFrom = sSrc
  161.         fo.pTo = sDst
  162.         fo.fFlags = afOptions
  163.         fo.hWnd = Owner
  164.         ' Mask out invalid flags
  165.         fo.fFlags = fo.fFlags And FOF_COPYFLAGS
  166.         f = SHFileOperation(fo)
  167.         MoveAnyFile = (f = 0)
  168.     Else
  169.         ' Windows NT 3.51
  170.         On Error Resume Next
  171.         ' Name actually moves
  172.         Name sSrc As sDst
  173.         If Err Then ' Probably you gave directory destination
  174.             Err = 0
  175.             sDst = MUtility.NormalizePath(sDst) & _
  176.                    MUtility.GetFileBaseExt(sSrc)
  177.             Name sSrc As sDst
  178.         End If
  179.         ' Enhance further to emulate SHFileOperation options
  180.         ' such as validation and wild cards
  181.         MoveAnyFile = (Err = 0)
  182.     End If
  183. End Function
  184.  
  185. Function RenameAnyFile(sSrc As String, sDst As String, _
  186.                        Optional Options As Long = 0, _
  187.                        Optional Owner As Long = hNull) As Boolean
  188.     If MUtility.HasShell Then
  189.         Dim fo As SHFILEOPSTRUCT, f As Long
  190.         fo.wFunc = FO_RENAME
  191.         'fo.pFrom = StrPtr(sSrc)
  192.         'fo.pTo = StrPtr(sDst)
  193.         fo.pFrom = sSrc
  194.         fo.pTo = sDst
  195.         fo.fFlags = Options
  196.         fo.hWnd = Owner
  197.         ' Mask out invalid flags
  198.         fo.fFlags = fo.fFlags And FOF_RENAMEFLAGS
  199.         f = SHFileOperation(fo)
  200.         RenameAnyFile = (f = 0)
  201.     Else
  202.         ' Windows NT 3.51
  203.         On Error Resume Next
  204.         Name sSrc As sDst
  205.         RenameAnyFile = (Err = 0)
  206.         ' Enhance further to emulate SHFileOperation options
  207.         ' such as validation and wild cards
  208.     End If
  209. End Function
  210.  
  211. Function DeleteAnyFile(sSrc As String, _
  212.                     Optional Options As Long = 0, _
  213.                     Optional Owner As Long = hNull) As Boolean
  214.     If MUtility.HasShell Then
  215.         Dim fo As SHFILEOPSTRUCT, f As Long
  216.         fo.wFunc = FO_DELETE
  217.         fo.pFrom = sSrc
  218.         ' fo.pTo = sNullStr
  219.         fo.fFlags = Options
  220.         fo.hWnd = Owner
  221.         ' Mask out invalid flags
  222.         fo.fFlags = fo.fFlags And FOF_DELETEFLAGS
  223.         f = SHFileOperation(fo)
  224.         DeleteAnyFile = (f = 0)
  225.     Else
  226.         ' Windows NT 3.51
  227.         On Error Resume Next
  228.         Kill sSrc
  229.         DeleteAnyFile = (Err = 0)
  230.         ' Enhance further to emulate SHFileOperation options
  231.         ' such as validation and wild cards
  232.     End If
  233. End Function
  234.  
  235. Function Files(hFiles As Long, fi As CFileInfo, _
  236.                ByVal sSpec As String, _
  237.                Optional afAttr As Long = 0) As String
  238.     Dim fd As WIN32_FIND_DATA, sName As String, f As Boolean, sPath As String
  239.     
  240.     ' Stop finding and close handle early
  241.     If afAttr = -1 Then
  242.         f = FindClose(hFiles)
  243.         hFiles = 0: Exit Function
  244.     End If
  245.     f = True
  246.     Do
  247.         ' Get first or next file
  248.         If hFiles = 0 Then
  249.             hFiles = FindFirstFile(sSpec, fd)
  250.         Else
  251.             f = FindNextFile(hFiles, fd)
  252.         End If
  253.         If (f = False Or hFiles = INVALID_HANDLE_VALUE) Then
  254.             If Err.LastDllError = ERROR_NO_MORE_FILES Then
  255.                 f = FindClose(hFiles)
  256.             End If
  257.             hFiles = 0: Exit Function
  258.         End If
  259.         ' Keep looping until something matches attributes
  260.     Loop While (afAttr <> vbNormal) And _
  261.                ((afAttr And fd.dwFileAttributes) = 0)
  262.     ' Get file data and return through reference
  263.     sPath = MUtility.GetFileDir(sSpec)
  264.     sName = MUtility.StrZToStr(MBytes.BytesToStr(fd.cFileName))
  265.     fi.CreateFromFile sPath & sName, fd.dwFileAttributes, _
  266.                       fd.nFileSizeLow, fd.ftLastWriteTime, _
  267.                       fd.ftLastAccessTime, fd.ftCreationTime
  268.     Files = sName
  269. End Function
  270.  
  271.  
  272. ' Efficient find files function
  273. Function FindFiles(sTarget As String, _
  274.                    Optional ByVal Start As String) As Collection
  275.  
  276.     ' Statics for less memory use in recursive procedure
  277.     Static sName As String, sSpec As String, nFound As New Collection
  278.     Static fd As WIN32_FIND_DATA, iLevel As Long
  279.     Dim hFiles As Long, f As Boolean
  280.     If Start = sEmpty Then Start = CurDir$
  281.     ' Maintain level to ensure collection is cleared first time
  282.     If iLevel = 0 Then
  283.         Set nFound = Nothing
  284.         Start = MUtility.NormalizePath(Start)
  285.     End If
  286.     iLevel = iLevel + 1
  287.     
  288.     ' Find first file (get handle to find)
  289.     hFiles = FindFirstFile(Start & "*.*", fd)
  290.     f = (hFiles <> INVALID_HANDLE_VALUE)
  291.     Do While f
  292.         sName = MBytes.ByteZToStr(fd.cFileName)
  293.         ' Skip . and ..
  294.         If Left$(sName, 1) <> "." Then
  295.             sSpec = Start & sName
  296.             If fd.dwFileAttributes And vbDirectory Then
  297.                 DoEvents
  298.                 ' Call recursively on each directory
  299.                 FindFiles sTarget, sSpec & "\"
  300.             ElseIf StrComp(sName, sTarget, 1) = 0 Then ' Text comparison
  301.                 ' Store found files in collection
  302.                 nFound.Add sSpec
  303.             End If
  304.         End If
  305.         ' Keep looping until no more files
  306.         f = FindNextFile(hFiles, fd)
  307.     Loop
  308.     f = FindClose(hFiles)
  309.     ' Return the matching files in collection
  310.     Set FindFiles = nFound
  311.     iLevel = iLevel - 1
  312. End Function
  313.  
  314. Function WalkAllFiles(fileit As IUseFile, _
  315.                       Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
  316.                       Optional ByVal Start As String) As Boolean
  317.  
  318.     ' Statics for less memory use in recursive procedure
  319.     Static sName As String, fd As WIN32_FIND_DATA, iLevel As Long
  320.     Static fi As New CFileInfo
  321.     Dim hFiles As Long, f As Boolean
  322.     If Start = sEmpty Then Start = CurDir$
  323.     ' Maintain level to ensure collection is cleared first time
  324.     If iLevel = 0 Then Start = MUtility.NormalizePath(Start)
  325.     iLevel = iLevel + 1
  326.     
  327.     ' Find first file (get handle to find)
  328.     hFiles = FindFirstFile(Start & "*.*", fd)
  329.     f = (hFiles <> INVALID_HANDLE_VALUE)
  330.     Do While f
  331.         sName = MBytes.ByteZToStr(fd.cFileName)
  332.         ' Skip . and ..
  333.         If Left$(sName, 1) <> "." Then
  334.             ' Create a file info object from file data
  335.             fi.CreateFromFile Start & sName, fd.dwFileAttributes, _
  336.                               fd.nFileSizeLow, fd.ftLastWriteTime, _
  337.                               fd.ftLastAccessTime, fd.ftCreationTime
  338.             If fd.dwFileAttributes And vbDirectory Then
  339.                 If ewmf And ewmfDirs Then
  340.                     ' Let client use directory data
  341.                     WalkAllFiles = fileit.UseFile(iLevel, Start, fi)
  342.                     ' If client returns True, walk terminates
  343.                     If WalkAllFiles Then Exit Function
  344.                 End If
  345.                 ' Call recursively on each directory
  346.                 WalkAllFiles = WalkAllFiles(fileit, ewmf, _
  347.                                             Start & sName & "\")
  348.             Else
  349.                 If ewmf And ewmfFiles Then
  350.                     ' Let client use file data
  351.                     WalkAllFiles = fileit.UseFile(iLevel, Start, fi)
  352.                     ' If client returns True, walk terminates
  353.                     If WalkAllFiles Then Exit Function
  354.                 End If
  355.             End If
  356.         End If
  357.         ' Keep looping until no more files
  358.         f = FindNextFile(hFiles, fd)
  359.     Loop
  360.     f = FindClose(hFiles)
  361.     ' Return the matching files in collection
  362.     iLevel = iLevel - 1
  363. End Function
  364.  
  365. Function WalkFiles(fileit As IUseFile, _
  366.                    Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
  367.                    Optional ByVal Start As String, _
  368.                    Optional UserData As Variant) As Boolean
  369.  
  370.     Dim sName As String, sSpec As String, fd As WIN32_FIND_DATA
  371.     Dim hFiles As Long, f As Boolean, fi As New CFileInfo
  372.     If Start = sEmpty Then Start = CurDir$
  373.     Start = MUtility.NormalizePath(Start)
  374.     
  375.     ' Find first file (get handle to find)
  376.     hFiles = FindFirstFile(Start & "*.*", fd)
  377.     f = (hFiles <> INVALID_HANDLE_VALUE)
  378.     Do While f
  379.         sName = MBytes.ByteZToStr(fd.cFileName)
  380.         ' Skip . and ..
  381.         If Left$(sName, 1) <> "." Then
  382.             ' Create a file info object from file data
  383.             fi.CreateFromFile Start & sName, fd.dwFileAttributes, _
  384.                               fd.nFileSizeLow, fd.ftLastWriteTime, _
  385.                               fd.ftLastAccessTime, fd.ftCreationTime
  386.             If fd.dwFileAttributes And vbDirectory Then
  387.                 If ewmf And ewmfDirs Then
  388.                     ' Let client use directory data
  389.                     WalkFiles = fileit.UseFile(UserData, Start, fi)
  390.                 End If
  391.             Else
  392.                 If ewmf And ewmfFiles Then
  393.                     ' Let client use file data
  394.                     WalkFiles = fileit.UseFile(UserData, Start, fi)
  395.                 End If
  396.             End If
  397.             ' If client returns True, walk terminates
  398.             If WalkFiles Then Exit Function
  399.         End If
  400.         ' Keep looping until no more files
  401.         f = FindNextFile(hFiles, fd)
  402.     Loop
  403.     f = FindClose(hFiles)
  404. End Function
  405. '
  406.  
  407. #If fComponent = 0 Then
  408. Private Sub ErrRaise(e As Long)
  409.     Dim sText As String, sSource As String
  410.     If e > 1000 Then
  411.         sSource = App.ExeName & ".FileTool"
  412.         Select Case e
  413.         Case eeBaseFileTool
  414.             BugAssert True
  415.        ' Case ee...
  416.        '     Add additional errors
  417.         End Select
  418.         Err.Raise COMError(e), sSource, sText
  419.     Else
  420.         ' Raise standard Visual Basic error
  421.         sSource = App.ExeName & ".VBError"
  422.         Err.Raise e, sSource
  423.     End If
  424. End Sub
  425. #End If
  426.  
  427.